perm filename PLTOTF.SAI[MF,DEK] blob
sn#554423 filedate 1981-01-08 generic text, type T, neo UTF8
begin "pltotf" comment Tfm file maker
edited by Ramshaw, December 10, 1980 9:42 PM
changed codingscheme names as per request of DEK
edited by Ramshaw, November 13, 1980 10:47 AM
added SevenBitSafe flag
edited by Ramshaw, November 10, 1980 2:27 PM
new Tfm and PL formats (what else?)
edited by Wyatt, September 4, 1979 10:43 AM
new Tfm and PL formats
edited by Wyatt, May 16, 1979 2:59 PM
this is a variation of pltotf which makes "Tfm" files for Alto
edited by Wyatt, April 27, 1979 4:54 PM
now understands special math font info in sy and ex fonts
edited by Wyatt, October 13, 1978 2:59 PM
now produces new TFP format
edited by Guibas, August 30, 1978 11:14 AM;
DEFINE WAITS=TRUE, TENEX=FALSE;
comment pltotf transforms a font metric information file from
PL (property list) to TF (tex font metric - TFM) format;
comment reads a file of the following form (standard extension .PL):
(Text including "--" and following on the line is annotations for the reader.
It must not appear in the PL file.)
(FAMILY CMR)
(FACE F MRR) -- "F" indicates PARC-Face-Byte code (could be octal instead)
(CODINGSCHEME TEX text) -- lots of other choices as well
(CHECKSUM O 1234567) -- unique version ID, "O" indicates octal integer
(DESIGNSIZE D 10) -- "D" indicates decimal integer
(COMMENT designsize is always in points) -- for adding comments in the PL file
(SEVENBITSAFEFLAG TRUE) -- if set, guarantees that lig/kern program and other
exotica won't take you from a seven bit character to an eight bit one
(POINTSIZE D 10) -- optional: relates ems to distances (points)
(MICASIZE D 383) -- optional: relates ems to distances (micas)
(RESOLUTION R 384.0) -- optional: relates pixels to distances, "R" means real
(COMMENT resolution is always in pixels/inch)
(UNITS POINTS) -- unit of measurement for distances
(UNITS MICAS)
(UNITS PIXELS)
(UNITS EMS) --means a distance that should be scaled by font size
(COMMENT size better be defined before distances in points or micas
are given: either POINTSIZE or MICASIZE will do)
(COMMENT resolution also better be defined before giving distances in pixels)
(COMMENT if you use ems, you don't need to give size or resolution)
(UNITS POINTS)
(TEXINFO
(SLANT R 0.250) -- slant is x units per y unit (NOT a distance)
(SPACE X 4 0)
(COMMENT "X" is for fixed-point: 16-bit integer and fraction parts follow)
(STRETCH X 2 0)
(SHRINK X 2 0)
(XHEIGHT R 4.444444 )
(QUAD R 10.00000 )
)
(LIGTABLE
(LABEL C f) -- ligatures for character f start here
(LIG C f O 173) -- "O" is for octal, indicating char code
(LIG C i O 174) -- if followed by i become '174 (fi)
(LIG C l O 175)
(STOP)
(LABEL C A)
(KRN C T R 0.29877) -- if followed by T, use specified kern
(STOP)
) -- this is the ligature and kern table
(COMMENT and maybe other font-wide parameters)
(CHARACTER C f -- C stands for character
(COMMENT lower case f)
(CHARWD R 3.333333 )
(CHARHT R 6.944444 )
(CHARDP R .0000000 )
(CHARIC R .0000000 )
(COMMENT -- for the benefit of the human reader
(LIG C f O 173)
(LIG C i O 174)
(LIG C l O 175)
)
)
(COMMENT more characters, as above)
;
require "⊂⊃⊂⊃" delimiters;
define #=⊂;comment ⊃;
define thru=⊂step 1 until⊃;
define DEBUG=⊂comment⊃ # change to ⊂comment⊃ for debugged version;
define saf=⊂safe⊃;
define simp=⊂simple⊃;
DEBUG redefine saf=⊂⊃, simp=⊂⊃;
external procedure bail;
integer array htarry,dparry,wdarry,icarry[0:257] # secondary font info tables;
integer htn,wdn,dpn,icn # number of heights, widths, etc. (after quantize);
integer array kernvals[0:255] # kern values;
integer array ligtable[0:255] # ligature table;
integer array exttable[0:255] # extension table;
integer array pararry[0:30] # fontpar (texinfo) array;
integer krn,lgn,exn,prn # number of entries in kernvals, ligtable, etc.;
integer bc,ec # first and last existing char codes;
integer fln # length of entire .tfm file;
define hdn=⊂18⊃ # length of .tfm header;
integer array finfo[0:255] # TEX font information: htx, dpx, etc. packed;
integer array charry[0:257] # auxiliary array for sorting;
integer array bufarry[0:3000] # used for buffering the output;
integer tfpptr # pointer into bufarry;
define bufout(x)=⊂begin bufarry[tfpptr]←x; tfpptr←tfpptr+1; end⊃;
define roundto32(x)=⊂((x+8) land (lnot '17))⊃;
define neginfinity=⊂'400000000000⊃;
define posinfinity=⊂'377777777777⊃;
define notthere=⊂'400000000001⊃ # used in htarry, ..., icarry to indicate
non-existent character (sorts to the front);
comment sizes and positions of fields in finfo;
define
wdbits=8,
htbits=4,
dpbits=4,
icbits=6,
tgbits=2,
rmbits=8;
define
rmfield=4,
tgfield=rmfield+rmbits,
icfield=tgfield+tgbits,
dpfield=icfield+icbits,
htfield=dpfield+dpbits,
wdfield=htfield+htbits;
define
htmax=1 lsh htbits,
dpmax=1 lsh dpbits,
wdmax=1 lsh wdbits,
icmax=1 lsh icbits,
rmmax=1 lsh rmbits;
define tagnone=0, taglig=1, taglist=2, tagvar=3 # rmfield tags;
real pixelsPerInch, pointsPerEm;
define pointsPerInch=⊂72.27⊃;
define micasPerInch=⊂2540⊃;
define pointsPerMica=⊂pointsPerInch/micasPerInch⊃;
integer checksum, designsize, face; string family, codingscheme;
boolean sevenbitsafe;
real cf # conversion factor for current unit of distance;
integer chan, ochan, eof, brchar;
string filename, outfilename;
IFC WAITS THENC
integer ocount, obrchar, oeof, i, c; string array namef[1:3];
ENDC
label abort;
comment fundamental units are ems;
integer procedure fix(real r);
begin
integer int;
int←(r*(2↑24))+0.5;
return(int);
end;
define crlf=⊂('15&'12)⊃;
define complain(x)=⊂begin print(crlf,x); DEBUG bail; goto abort; end⊃;
define setfinfo(c,f,i)=⊂finfo[c]←finfo[c] lor (i lsh f)⊃;
define settgfield(c,tag,info)=
⊂begin
integer curtag;
curtag←(finfo[c] lsh -tgfield) land 3;
if curtag=tagnone then
finfo[c]←finfo[c] lor ((((tag)lsh rmbits)+(info))lsh rmfield)
else if curtag=tag then
complain(⊂"Attempt to reset property of char: "&cvos(c)⊃)
else
complain(⊂"VarChar, CharList, and LigKern are mutually exclusive, char = "&cvos(c)⊃);
end⊃;
comment here come the Key-Words we use;
define
KWcomment=1,
KWfamily=KWcomment+1,
KWcodingscheme=KWfamily+1,
KWchecksum=KWcodingscheme+1,
KWdesignsize=KWchecksum+1,
KWsevenbitsafeflag=KWdesignsize+1,
KWface=KWsevenbitsafeflag+1,
KWunits=KWface+1,
KWmicas=KWunits+1,
KWpoints=KWmicas+1,
KWpixels=KWpoints+1,
KWems=KWpixels+1,
KWpointsize=KWems+1,
KWmicasize=KWpointsize+1,
KWresolution=KWmicasize+1,
KWtexinfo=KWresolution+1,
KWslant=KWtexinfo+1,
KWspace=KWslant+1,
KWstretch=KWspace+1,
KWshrink=KWstretch+1,
KWxheight=KWshrink+1,
KWquad=KWxheight+1,
KWextraspace=KWquad+1,
KWmathspace=KWextraspace+1,
KWnum1=KWmathspace+1,
KWnum2=KWnum1+1,
KWnum3=KWnum2+1,
KWdenom1=KWnum3+1,
KWdenom2=KWdenom1+1,
KWsup1=KWdenom2+1,
KWsup2=KWsup1+1,
KWsup3=KWsup2+1,
KWsub1=KWsup3+1,
KWsub2=KWsub1+1,
KWsupdrop=KWsub2+1,
KWsubdrop=KWsupdrop+1,
KWdelim1=KWsubdrop+1,
KWdelim2=KWdelim1+1,
KWaxisheight=KWdelim2+1,
KWdefaultrulethickness=KWaxisheight+1,
KWbigopspacing1=KWdefaultrulethickness+1,
KWbigopspacing2=KWbigopspacing1+1,
KWbigopspacing3=KWbigopspacing2+1,
KWbigopspacing4=KWbigopspacing3+1,
KWbigopspacing5=KWbigopspacing4+1,
KWligtable=KWbigopspacing5+1,
KWlabel=KWligtable+1,
KWlig=KWlabel+1,
KWkrn=KWlig+1,
KWstop=KWkrn+1,
KWcharacter=KWstop+1,
KWcharwd=KWcharacter+1,
KWcharht=KWcharwd+1,
KWchardp=KWcharht+1,
KWcharic=KWchardp+1,
KWnextlarger=KWcharic+1,
KWvarchar=KWnextlarger+1,
KWtop=KWvarchar+1,
KWmid=KWtop+1,
KWbot=KWmid+1,
KWext=KWbot+1,
KWmax=KWext;
string array keywords[1:KWmax];
integer KWptr;
integer procedure matchkeyword(string kw);
begin "matchkeyword" comment note that KWptr is global and is used
more or less as a roving pointer to speed up searches;
integer KWstart;
KWstart←KWptr;
while true do
begin
KWptr←KWptr+1;
if KWptr>KWmax then KWptr←1;
if equ(kw, keywords[KWptr]) then return(KWptr);
if KWptr=KWstart then done;
end;
return(0);
end "matchkeyword";
define
BTskipblanks=1,
BTscankeyword=2,
BTscannumber=3,
BTscancomment=4,
BTscanchar=5,
BTmax=BTscanchar;
integer array breaktables[1:BTmax];
procedure initbreaktables;
begin "initbreaktables"
integer i;
string digits, letters, blanks;
digits←"0123456789";
letters←"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz";
blanks←'40&'12&'14&'15&'11 # space, lf, ff, cr, tab;
for i←1 thru BTmax do breaktables[i]←getbreak;
breakset(breaktables[BTskipblanks], blanks, "X");
breakset(breaktables[BTskipblanks], null, "R");
breakset(breaktables[BTscankeyword], null, "K");
breakset(breaktables[BTscankeyword], letters&digits, "X");
breakset(breaktables[BTscankeyword], null, "R");
breakset(breaktables[BTscannumber], digits&"+-", "X");
breakset(breaktables[BTscannumber], null, "R");
breakset(breaktables[BTscancomment], "()", "I");
breakset(breaktables[BTscancomment], null, "R");
breakset(breaktables[BTscanchar], null, "X");
breakset(breaktables[BTscanchar], null, "A");
end "initbreaktables";
define skipblanks=⊂input(chan, breaktables[BTskipblanks])⊃;
define inp(str, bt)=⊂skipblanks; str←input(chan, breaktables[bt])⊃;
IFC WAITS THENC
integer procedure charin(integer chan); begin
integer c;
c←input(chan,breaktables[BTscanchar]);
return(c);
end;
ENDC
procedure scancomment;
begin "scancomment"
integer plevel;
plevel←1 # parenthesis level;
while true do
begin
input(chan, breaktables[BTscancomment]) # scan up to "(" or ")";
if brchar="(" then begin charin(chan); plevel←plevel+1; end
else begin if (plevel←plevel-1)>0 then charin(chan) else done end;
end;
end "scancomment";
integer procedure encodeface(string f);
begin
integer i,c,code;
code←0;
c←f[3 to 3];
if c="C" then code←code+1
else if c="E" then code←code+2;
code←code*3;
c←f[1 to 1];
if c="B" then code←code+1
else if c="L" then code←code+2;
code←code*2;
c←f[2 to 2];
if c="I" then code←code+1;
return(code);
end;
string procedure getstring;
begin "getstring"
string str;
inp(str, BTscankeyword);
return(str);
end "getstring";
real procedure getreal;
begin "getreal"
string str; integer type;
skipblanks;
type←charin(chan);
if type="O" then comment octal value;
begin
inp(str, BTscannumber);
return(cvo(str));
end
else if type="D" then comment decimal value;
begin
inp(str, BTscannumber);
return(cvd(str));
end
else if type="R" then
return(realin(chan)) comment real value;
else if type="X" then comment funny float format - a signed 16 bit
integer followed by an unsigned 16
bit fractional part;
begin
real x;
inp(str, BTscannumber);
x←cvd(str);
inp(str, BTscannumber);
x←x+(cvd(str)/(1 lsh 16));
return(x);
end
else complain(⊂"invalid type in getreal: "&type⊃);
end "getreal";
integer procedure getdistance;
return(fix(getreal*cf));
integer procedure getinteger;
begin "getinteger"
string str; integer type;
skipblanks;
type←charin(chan);
if type="D" then comment absolute decimal value;
begin
inp(str, BTscannumber);
return(cvd(str));
end
else if type="O" then comment absolute octal value;
begin
inp(str, BTscannumber);
return(cvo(str));
end
else if type="C" then comment character;
begin
skipblanks;
return(charin(chan));
end
else if type="F" then comment PARC-style face code;
begin
inp(str,BTscankeyword);
return(encodeface(str));
end
else complain(⊂"invalid type in getinteger: "&type⊃);
end "getinteger";
integer procedure getcharcode;
begin "getcharcode"
integer ch;
ch←getinteger;
if ch<0 or ch≥'400 then
complain(⊂"character code out of range: ",cvos(ch)⊃);
return(ch);
end "getcharcode";
integer procedure getPARCface;
begin "getPARCface"
integer ch;
ch←getinteger;
if ch<0 or ch≥'400 then
complain(⊂"PARC face code out of range: ",cvos(ch)⊃);
return(ch);
end "getPARCface";
boolean procedure beginitem;
begin "beginitem"
skipblanks;
if brchar="(" then begin charin(chan); return(true) end
else return(false);
end "beginitem";
procedure enditem;
begin "enditem"
skipblanks;
if charin(chan)=")" then return
else complain(⊂"end of item expected"⊃);
end "enditem";
string kwstring;
integer procedure getkw;
begin "getkw"
integer kw;
kwstring←getstring;
kw←matchkeyword(kwstring);
if kw=0 then complain(⊂"unknown keyword: ",kwstring⊃);
return(kw);
end "getkw";
boolean procedure getboolean;
begin "getboolean"
string str;
str←getstring;
if equ(str,"TRUE") then return(true)
else if equ(str,"FALSE") then return(false)
else complain(⊂"not a boolean value: ",str⊃);
end "getboolean";
procedure init;
begin "init" comment first initialize keyword table;
keywords[KWcomment]←"COMMENT";
keywords[KWfamily]←"FAMILY";
keywords[KWcodingscheme]←"CODINGSCHEME";
keywords[KWchecksum]←"CHECKSUM";
keywords[KWdesignsize]←"DESIGNSIZE";
keywords[KWsevenbitsafeflag]←"SEVENBITSAFEFLAG";
keywords[KWface]←"FACE";
keywords[KWunits]←"UNITS";
keywords[KWmicas]←"MICAS";
keywords[KWpoints]←"POINTS";
keywords[KWpixels]←"PIXELS";
keywords[KWems]←"EMS";
keywords[KWpointsize]←"POINTSIZE";
keywords[KWmicasize]←"MICASIZE";
keywords[KWresolution]←"RESOLUTION";
keywords[KWtexinfo]←"TEXINFO";
keywords[KWslant]←"SLANT";
keywords[KWspace]←"SPACE";
keywords[KWstretch]←"STRETCH";
keywords[KWshrink]←"SHRINK";
keywords[KWxheight]←"XHEIGHT";
keywords[KWquad]←"QUAD";
keywords[KWextraspace]←"EXTRASPACE";
keywords[KWmathspace]←"MATHSPACE";
keywords[KWnum1]←"NUM1";
keywords[KWnum2]←"NUM2";
keywords[KWnum3]←"NUM3";
keywords[KWdenom1]←"DENOM1";
keywords[KWdenom2]←"DENOM2";
keywords[KWsup1]←"SUP1";
keywords[KWsup2]←"SUP2";
keywords[KWsup3]←"SUP3";
keywords[KWsub1]←"SUB1";
keywords[KWsub2]←"SUB2";
keywords[KWsupdrop]←"SUPDROP";
keywords[KWsubdrop]←"SUBDROP";
keywords[KWdelim1]←"DELIM1";
keywords[KWdelim2]←"DELIM2";
keywords[KWaxisheight]←"AXISHEIGHT";
keywords[KWdefaultrulethickness]←"DEFAULTRULETHICKNESS";
keywords[KWbigopspacing1]←"BIGOPSPACING1";
keywords[KWbigopspacing2]←"BIGOPSPACING2";
keywords[KWbigopspacing3]←"BIGOPSPACING3";
keywords[KWbigopspacing4]←"BIGOPSPACING4";
keywords[KWbigopspacing5]←"BIGOPSPACING5";
keywords[KWligtable]←"LIGTABLE";
keywords[KWlabel]←"LABEL";
keywords[KWlig]←"LIG";
keywords[KWkrn]←"KRN";
keywords[KWstop]←"STOP";
keywords[KWcharacter]←"CHARACTER";
keywords[KWcharwd]←"CHARWD";
keywords[KWcharht]←"CHARHT";
keywords[KWchardp]←"CHARDP";
keywords[KWcharic]←"CHARIC";
keywords[KWnextlarger]←"NEXTLARGER";
keywords[KWvarchar]←"VARCHAR";
keywords[KWtop]←"TOP";
keywords[KWmid]←"MID";
keywords[KWbot]←"BOT";
keywords[KWext]←"EXT";
comment then make the break tables;
initbreaktables;
end "init";
procedure restinit;
begin "restinit"
comment and finally assign default values;
arrclr(finfo,0) # all characters are missing;
arrclr(htarry,notthere);
arrclr(dparry,notthere);
arrclr(wdarry,notthere);
arrclr(icarry,notthere);
arrclr(pararry,0);
krn←lgn←exn←0;
family←"UNSPECIFIED";
face←"MRR";
pixelsPerInch←0 # means unspecified;
pointsPerEm←0 # means unspecified;
codingscheme←"UNSPECIFIED";
sevenbitsafe←false # default is not safe;
cf←1.0 # default UNITS are EMS;
end "restinit";
string procedure scancodingscheme;
begin
string str;
str←getstring;
while true do
begin
skipblanks;
if brchar=")" then done;
str←str&" "&getstring;
end;
return(str);
end;
define topd=24+4, midd=16+4, botd=8+4, extd=0+4;
procedure scanvarchar(integer c);
begin integer x; x←0;
while beginitem do
begin integer kw,d;
KWptr←KWvarchar+1;
kw←getkw;
case kw of
begin "varcases"
[KWtop] d←topd; [KWmid] d←midd;
[KWbot] d←botd; [KWext] d←extd;
[KWcomment] scancomment;
else complain(⊂"Illegal keyword in VARCHAR specification: ",kwstring⊃)
end "varcases";
x←x lor (getcharcode lsh d);
enditem;
end;
settgfield(c,tagvar,exn); exttable[exn]←x; exn←exn+1;
end;
procedure scancharacterdata(integer c);
begin "scancharacterdata"
integer kw, j;
j←c+1 # index into wdarry, etc.;
while beginitem do
begin
KWptr←KWcharacter+1;
kw←getkw;
case kw of
begin "charcases"
comment note that wdarry...icarry are 1-origin;
[KWcharwd] wdarry[j]←getdistance;
[KWcharht] htarry[j]←getdistance;
[KWchardp] dparry[j]←getdistance;
[KWcharic] icarry[j]←getdistance;
[KWnextlarger] settgfield(c,taglist,getcharcode);
[KWvarchar] scanvarchar(c);
[KWcomment] scancomment;
else complain(⊂"Illegal keyword in CHARACTER specification: ",kwstring⊃)
end "charcases";
enditem;
end;
if wdarry[j]=notthere then
begin wdarry[j]←0; print(" CHARWD missing") end;
if htarry[j]=notthere then
begin htarry[j]←0; print(" CHARHT missing") end;
if dparry[j]=notthere then
begin dparry[j]←0; print(" CHARDP missing") end;
if icarry[j]=notthere then
icarry[j]←0 # zero is the default;
end "scancharacterdata";
procedure scanligtable;
begin "scanligtable"
define lookup(f,x,a,n) =
⊂begin a[n]←x; for f←0 step 1 until n do
if a[f]=x then done; if f=n then n←n+1; end⊃;
define lig(c,d) =
⊂ligtable[lgn]←((c lsh 16)+d)lsh 4; lgn←lgn+1⊃ # ligature
(if next character is c, use ligature d);
define kern(c,x) =
⊂ligtable[lgn]←((c lsh 16)+(1 lsh 15)+x)lsh 4; lgn←lgn+1⊃ #
kern (if next character is c, put in kernvalue[x] space);
define endlig =
⊂ligtable[lgn-1]←ligtable[lgn-1] lor (1 lsh 35)⊃ # turns
stop bit on (end instructions);
integer kw;
lgn←0;
while beginitem do
begin
KWptr←KWligtable+1;
kw←getkw;
case kw of
begin "ligcases"
[KWlabel]
begin integer c;
c←getcharcode; settgfield(c,taglig,lgn);
end;
[KWlig]
begin integer c1,c2;
c1←getcharcode; c2←getcharcode;
lig(c1,c2);
end;
[KWkrn]
begin integer x,c1,kn;
c1←getcharcode; x←getdistance;
lookup(kn,x,kernvals,krn);
kern(c1,kn);
end;
[KWstop] endlig;
[KWcomment] scancomment;
else complain(⊂"Illegal keyword in LIGTABLE: ",kwstring⊃)
end "ligcases";
enditem;
end;
end "scanligtable";
define
slant=0,
space=slant+1,
stretch=space+1,
shrink=stretch+1,
xheight=shrink+1,
quad=xheight+1,
extraspace=quad+1,
mathspace=extraspace,
num1=mathspace+1,
num2=num1+1,
num3=num2+1,
denom1=num3+1,
denom2=denom1+1,
sup1=denom2+1,
sup2=sup1+1,
sup3=sup2+1,
sub1=sup3+1,
sub2=sub1+1,
supdrop=sub2+1,
subdrop=supdrop+1,
delim1=subdrop+1,
delim2=delim1+1,
axisheight=delim2+1,
defaultrulethickness=extraspace+1,
bigopspacing1=defaultrulethickness+1,
bigopspacing2=bigopspacing1+1,
bigopspacing3=bigopspacing2+1,
bigopspacing4=bigopspacing3+1,
bigopspacing5=bigopspacing4+1;
define
stdpars=extraspace+1,
sypars=axisheight+1,
expars=bigopspacing5+1;
procedure scantexinfo;
begin
while beginitem do
begin integer kw,p;
p←0; kw←getkw;
case kw of
begin "infocases"
[KWslant] p←slant;
[KWspace] p←space;
[KWstretch] p←stretch;
[KWshrink] p←shrink;
[KWxheight] p←xheight;
[KWquad] p←quad;
[KWextraspace] p←extraspace;
[KWmathspace] p←mathspace;
[KWnum1] p←num1;
[KWnum2] p←num2;
[KWnum3] p←num3;
[KWdenom1] p←denom1;
[KWdenom2] p←denom2;
[KWsup1] p←sup1;
[KWsup2] p←sup2;
[KWsup3] p←sup3;
[KWsub1] p←sub1;
[KWsub2] p←sub2;
[KWsupdrop] p←supdrop;
[KWsubdrop] p←subdrop;
[KWdelim1] p←delim1;
[KWdelim2] p←delim2;
[KWaxisheight] p←axisheight;
[KWdefaultrulethickness] p←defaultrulethickness;
[KWbigopspacing1] p←bigopspacing1;
[KWbigopspacing2] p←bigopspacing2;
[KWbigopspacing3] p←bigopspacing3;
[KWbigopspacing4] p←bigopspacing4;
[KWbigopspacing5] p←bigopspacing5;
[KWcomment] scancomment;
else complain(⊂"Illegal keyword in TEXINFO: ",kwstring⊃)
end;
if p=slant then pararry[p]←fix(getreal)
else pararry[p]←getdistance;
enditem;
end;
end;
procedure scanfontdata;
begin "scanfontdata" integer kw;
while beginitem do
begin
KWptr←KWfamily;
kw←getkw;
case kw of
begin "fontcases"
[KWfamily] family←getstring;
[KWcodingscheme] codingscheme←scancodingscheme;
[KWchecksum] checksum←getinteger;
[KWdesignsize] designsize←fix(getreal);
[KWsevenbitsafeflag] sevenbitsafe←getboolean;
[KWpointsize] pointsPerEm←getreal;
[KWmicasize] pointsPerEm←getreal*pointsPerMica;
[KWresolution] pixelsPerInch←getreal;
[KWface] face←getPARCface;
[KWunits]
begin
integer ukw, temp;
ukw←getkw;
case ukw of
begin "unitcases"
[KWpoints] [KWmicas] [KWpixels] [KWems] ;
else complain(⊂"Illegal UNITS: ", kwstring⊃)
end "unitcases";
if ukw=KWems then cf←1.0
else if pointsPerEm=0 then
complain(⊂"size undefined: POINTSIZE or MICASIZE"⊃)
else if ukw=KWpoints then cf←1/pointsPerEm
else if ukw=KWmicas then
cf←pointsPerMica/pointsPerEm
else if pixelsPerInch=0 then
complain(⊂"RESOLUTION undefined"⊃)
else cf←pointsPerInch/(pixelsPerInch*pointsPerEm);
end;
[KWtexinfo] scantexinfo;
[KWligtable] scanligtable;
[KWcharacter]
begin integer c;
c←getcharcode;
print(" ",cvos(c)) # inform user of progress;
scancharacterdata(c);
end;
[KWcomment] scancomment;
else complain(⊂"Illegal keyword in font specification: ",kwstring⊃)
end "fontcases";
enditem;
end;
end "scanfontdata";
procedure sort(reference integer array srtarry, auxarry; integer n);
comment quicksort with insertionsort at the end;
begin "sort" integer i, lv;
integer pp, l, r, j, v, t, tk, lk;
define m=9;
integer array stack[0:2*(log(8192/(m+2)) div 1)+1];
label part, right, rbig, left, pop, insert;
srtarry[0] ← neginfinity; srtarry[n+1] ← posinfinity;
pp ← 0; l ← 1; r ← n;
part: i ← l; j ← r+1; v ← srtarry[l];
while i < j do begin
i←i+1; while srtarry[i]<v do i ← i+1;
j←j-1; while srtarry[j]>v do j ← j-1;
tk←srtarry[j]; srtarry[j]←srtarry[i]; srtarry[i]←tk;
lk←auxarry[j]; auxarry[j]←auxarry[i]; auxarry[i]←lk;
end;
srtarry[i]←srtarry[j]; srtarry[j]←srtarry[l]; srtarry[l]←tk;
auxarry[i]←auxarry[j]; auxarry[j]←auxarry[l]; auxarry[l]←lk;
if r-j > j-l then go to rbig;
if j-l leq m then go to pop;
if r-j leq m then go to left;
pp ← pp+2;
stack[pp]←l;
stack[pp+1]←j-1;
right: l←j+1;
go to part;
rbig: if r-j leq m then go to pop;
if j-l leq m then go to right;
pp←pp+2;
stack[pp]←j+1;
stack[pp+1]←r;
left: r←j-1;
go to part;
pop: l←stack[pp];
r←stack[pp+1];
pp←pp-2;
if pp geq 0 then go to part;
insert: for i ← 2 step 1 until n do
begin
v←srtarry[i]; j←i-1;
lv←auxarry[i];
while srtarry[j]>v do
begin
srtarry[j+1]←srtarry[j];
auxarry[j+1]←auxarry[j];
j←j-1;
end;
srtarry[j+1]←v;
auxarry[j+1]←lv;
end;
end "sort";
procedure quantize(reference integer array magnitude;
integer maxnvals, del, field; boolean widthflg);
begin "quantize"
comment this procedure selects a set of ≤maxnvals values to
"represent" all the distinct values in the magnitude array;
comment the data value zero is always treated somewhat specially,
due to the requirement that the 0'th entry of the height,
width, depth, and ic arrays in the .tfm be 0. In the width
case, furthermore, we must NOT use index zero to represent
zero data values (since it marks a non-existent character).
But in the other three cases we should use index zero for
all zero data values;
integer i, j, mask, nvals, prev, code;
record_class cluster(integer index,extent;
record_pointer(any_class) next);
record_pointer(cluster) head, tail, oldrec, newrec;
for i←1 thru 256 do charry[i]←i-1;
bufout(0) # element zero of the .tfm table;
if not widthflg then
for i←1 thru 256 do if magnitude[i]=0 then
begin
setfinfo(charry[i], field, 0);
magnitude[i]←notthere;
end;
sort(magnitude, charry, 256);
comment find first non-NIL entry;
j←1;
while magnitude[j]=notthere do j←j+1;
if j > 256 then return # nothing to do (no entries or all zeros);
print(" del:");
while true do
begin
print(" ",del);
mask← -1 lsh del;
nvals←1 # count zero as one;
prev←-1;
for i←j thru 256 do
begin
integer t;
t←magnitude[i] land mask;
if t neq prev then
begin
nvals←nvals+1;
if nvals>maxnvals then done;
prev←t;
end;
end;
if nvals≤maxnvals then done;
del←del+1;
end;
comment now del is large enough;
print(". nvals=",nvals);
oldrec←head←new_record(cluster);
cluster:index[head]←j;
prev←magnitude[j] land mask;
for i←j+1 thru 256 do
begin
integer t;
t←magnitude[i] land mask;
if t neq prev then
begin
cluster:extent[oldrec]←
magnitude[i-1]-magnitude[cluster:index[oldrec]];
cluster:next[oldrec]←newrec←new_record(cluster);
cluster:index[newrec]←i;
oldrec←newrec;
prev←t;
end;
end;
tail←new_record(cluster);
cluster:index[tail]←257;
cluster:next[oldrec]←tail;
cluster:extent[oldrec]←magnitude[256]-magnitude[cluster:index[oldrec]];
while nvals<maxnvals do
begin
integer l,u,m;
integer maxextent;
maxextent←-1;
oldrec←null_record;
newrec←head;
while newrec neq tail do
begin
if cluster:extent[newrec]>maxextent then
begin
oldrec←newrec;
maxextent←cluster:extent[newrec]
end;
newrec←cluster:next[newrec];
end;
if maxextent=0 then done;
newrec←new_record(cluster);
l←cluster:index[oldrec];
u←cluster:index[cluster:next[oldrec]]-1;
m←(l+u) div 2 # maybe do something smarter later;
cluster:index[newrec]←m+1;
cluster:extent[newrec]←magnitude[u]-magnitude[m+1];
cluster:next[newrec]←cluster:next[oldrec];
cluster:extent[oldrec]←magnitude[m]-magnitude[l];
cluster:next[oldrec]←newrec;
nvals←nvals+1;
end;
comment now we have the largest possible number of values
less than or equal to maxnvals;
code←1;
oldrec←head;
while oldrec neq tail do
begin
integer l, u, sum, mean;
l←cluster:index[oldrec];
u←cluster:index[cluster:next[oldrec]]-1;
sum←0;
for i←l thru u do sum←sum+magnitude[i];
mean←(sum/(u-l+1))+0.5;
bufout(roundto32(mean));
for i←l thru u do setfinfo(charry[i], field, code);
oldrec←cluster:next[oldrec];
code←code+1;
end;
end "quantize";
procedure addextensions;
begin "addextensions"
comment add mathex font extension character codes to bufarry;
integer i,x;
for i←0 thru exn-1 do
bufout(exttable[i]);
end "addextensions";
procedure addfontparams;
begin "addfontparams"
integer i,n;
if equ(codingscheme, "TEX MATHSY") then n←sypars
else if equ(codingscheme, "TEX MATHEX") then n←expars
else n←stdpars;
for i←0 thru n-1 do bufout(roundto32(pararry[i]));
end "addfontparams";
boolean procedure openinputfile;
begin "openinputfile"
comment several TENEX-specific calls in here;
string name;
external integer !skip!;
while true do
begin
print("PL input file: ");
IFC TENEX THENC
release(chan) # close old input if any;
chan←gtjfnl(null,'100100000000,'000100000101,
null,null,null,"PL",null,null,0);
if !skip!≠0 then
begin print(crlf, "What?", crlf); continue end;
openf(chan,2);
if !skip!≠0 then
begin print(crlf, "Can't open that file!", crlf);
continue end;
ENDC
IFC WAITS THENC
open(chan←getchan,"DSK",0,19,0,400,brchar,eof);
open(ochan←getchan,"DSK",8,0,19,ocount,obrchar,oeof);
name←inchwl;
namef[1]←namef[2]←namef[3]←"";
i←1;
while c←lop(name) do begin
if c="." then i←2
else if c="[" then i←3;
namef[i]←namef[i]&c;
end;
if namef[2]="" then namef[2]←".PL";
name←namef[1]&namef[2]&namef[3];
lookup(chan,name,eof);
if eof then begin
print(crlf, "Can't open ",name,crlf); continue end;
name←namef[1]&".TFM"&namef[3];
enter(ochan,name,oeof);
if oeof then begin
print(crlf, "Can't open ",name,crlf); continue end;
ENDC
return(true)
end;
end "openinputfile";
procedure buildtfparry;
begin "buildtfparry"
integer p,i;
define quant(a,m,d,f,ff)=⊂print(crlf,"a:"); quantize(a,m,d,f,ff)⊃;
define setlen(x)=⊂x←tfpptr-p; p←tfpptr; print(" x=",x)⊃;
tfpptr←0;
p←tfpptr;
quant(wdarry, wdmax, 0, wdfield, true);
setlen(wdn);
quant(htarry, htmax, 0, htfield, false);
setlen(htn);
quant(dparry, dpmax, 0, dpfield, false);
setlen(dpn);
quant(icarry, icmax, 0, icfield, false);
setlen(icn);
print(crlf,"ligatures:"); for i←0 thru lgn-1 do bufout(ligtable[i]);
setlen(lgn);
print(crlf,"kerns:"); for i←0 thru krn-1 do
bufout(roundto32(kernvals[i]));
setlen(krn);
print(crlf,"extensions:"); addextensions;
setlen(exn);
print(crlf,"fontparams:"); addfontparams;
setlen(prn);
end "buildtfparry";
procedure BCPLout(string str; integer total);
begin
integer totalwds,len,i,bp;
if total mod 4 ≠0 then complain(⊂"confusion"⊃);
totalwds←total div 4;
len←length(str) min (total-1);
begin
integer array buf[0:totalwds-1];
bp←point(8,buf[0],-1);
idpb(len,bp);
for i←1 thru len do idpb(str[i for 1],bp);
for i←len+1 thru total-1 do idpb(0,bp);
arryout(ochan,buf[0],totalwds);
end;
end;
procedure tfout(string oname) # outputs the TEX font information file;
begin "tfout" integer i,l;
for bc←0 step 1 until '377 do if finfo[bc]≠0 then done;
for ec←'377 step -1 until 0 do if finfo[ec]≠0 then done;
if bc>ec then begin bc←1; ec←0 end;
define halvesout(x,y)=
⊂wordout(ochan, (x lsh 20)lor((y land '177777) lsh 4))⊃;
fln←6+hdn+(ec-bc+1)+htn+wdn+dpn+icn+krn+lgn+exn+prn;
halvesout(fln,hdn);
halvesout(bc,ec);
halvesout(wdn,htn);
halvesout(dpn,icn);
halvesout(lgn,krn);
halvesout(exn,prn);
comment Now for 18 words of header:;
define fullout(x)=⊂wordout(ochan, x lsh 4)⊃;
fullout(checksum);
wordout(ochan,roundto32(designsize));
BCPLout(codingscheme, 40);
BCPLout(family, 20);
begin "write Random word"
integer i;
i←face lsh 4;
if sevenbitsafe then i←i lor (1 lsh 35);
wordout(ochan,i);
end "write Random word";
comment write finfo array;
arryout(ochan,finfo[bc],ec-bc+1);
comment now comes tfparry;
arryout(ochan,bufarry[0],tfpptr);
IFC TENEX THENC
comment If this were at SU-AI, we could just "cfile(chan)" but
on TENEX, we first need to change to byte size eight;
closf(ochan);
begin "play with file descriptor block"
integer fllen;
integer array fdb[0:'24];
gtfdb(ochan, fdb);
fllen←fdb['12];
comment change byte size to 8 (from 36);
chfdb(ochan, '11, (2↑6-1) lsh 24, 8 lsh 24);
comment and multiply EOF byte count by 4 to compensate;
chfdb(ochan, '12, -1, 4*fllen);
end "play with file descriptor block";
rljfn(ochan);
ENDC
IFC WAITS THENC
release(ochan);
ENDC
end "tfout";
comment the main program starts here;
init;
print("PLTOTF of December 10, 1980",crlf);
IFC TENEX THENC
while openinputfile do
do begin comment loop over all files in * group;
filename←jfns(chan, '001000000000) # name part only -- TENEX specific;
outfilename←filename&".TFM";
ochan←openfile(outfilename,"WA");
print(crlf,"TFM output file: ",jfns(ochan,0),crlf);
setinput(chan,400,brchar,eof);
ENDC
IFC WAITS THENC
openinputfile;
ENDC
restinit;
scanfontdata;
buildtfparry;
tfout(outfilename);
print(crlf,crlf);
IFC TENEX THENC
end until not indexfile(chan);
ENDC
abort:
end "pltotf"